home *** CD-ROM | disk | FTP | other *** search
/ Network PC / Network PC.iso / windows 95 utilities / programming tools / extended pagecontrol / extpage.int < prev    next >
Encoding:
Text File  |  1997-04-20  |  13.6 KB  |  412 lines
  1. Unit ExtPage;
  2.  
  3. //-------------------------------------------------------------//
  4. //                                                             //
  5. //   Components Extended PageControl & Extended TabControl     //
  6. //                                                             //
  7. //   Date:    April, 20 1997                                   //
  8. //   Version: 2.2                                              //
  9. //   Author:  Jan - M. Strube                                  //
  10. //   System:  Delphi 2.01 / Delphi 3 / Borland C++Builder      //
  11. //                                                             //
  12. //   http://ourworld.compuserve.com/homepages/praxisservice/   //
  13. //                                                             //
  14. //-------------------------------------------------------------//
  15.  
  16. {$DEFINE NODEBUG}           // DEBUG / NODEBUG
  17.  
  18. {$ALIGN ON}
  19. {$BOOLEVAL OFF}
  20. {$EXTENDEDSYNTAX ON}
  21. {$HINTS ON}
  22. {$LONGSTRINGS ON}
  23. {$OPTIMIZATION ON}
  24. {$SAFEDIVIDE OFF}
  25. {$STACKFRAMES OFF}
  26. {$TYPEDADDRESS ON}
  27. {$VARSTRINGCHECKS OFF}
  28. {$WARNINGS ON}
  29. {$WRITEABLECONST OFF}
  30.  
  31. {$IFDEF DEBUG}
  32.   {$DEBUGINFO ON}
  33.   {$LOCALSYMBOLS ON}
  34.   {$OVERFLOWCHECKS ON}
  35.   {$RANGECHECKS ON}
  36.   {$REFERENCEINFO ON}
  37.   {$STACKCHECKS ON}
  38. {$ELSE}
  39.   {$DEBUGINFO OFF}
  40.   {$LOCALSYMBOLS OFF}
  41.   {$OVERFLOWCHECKS OFF}
  42.   {$RANGECHECKS OFF}
  43.   {$REFERENCEINFO OFF}
  44.   {$STACKCHECKS OFF}
  45. {$ENDIF}
  46.  
  47. interface
  48.  
  49. uses
  50.   Windows, Messages, SysUtils, Classes, Graphics, Controls,
  51.   StdCtrls, ComCtrls, CommCtrl;
  52.  
  53. const
  54.   TCS_BOTTOM = $0002;
  55.   TCS_RIGHT = $0002;
  56.   TCS_VERTICAL = $0080;
  57.  
  58. type
  59.   TExtGlyphPosition = (glPosLeft, glPosTop);
  60.  
  61.   TExtGlyphs = class(TPersistent)
  62.     private
  63.       FGlyph: TBitmap;
  64.       FGlyphPaint: TBitmap;
  65.       FGlpyhOwner: TControl;
  66.       FImageList: TImageList;
  67.       FNumGlyphs: Word;
  68.       FOnChange: TNotifyEvent;
  69.       FOnChangeGlyph: TNotifyEvent;
  70.       FPosition: TExtGlyphPosition;
  71.       FSpacing: Integer;
  72.       FTransparentColor: TColor;
  73.       procedure SetGlyph(Value: TBitmap);
  74.       procedure SetNumGlyphs(Value: Word);
  75.       procedure SetPosition(Value: TExtGlyphPosition);
  76.       procedure SetSpacing(Value: Integer);
  77.       procedure SetTransparentColor(Value: TColor);
  78.     protected
  79.       procedure Changed(Sender: TObject);
  80.       procedure ChangedGlyph(Sender: TObject);
  81.     public
  82.       constructor Create(AOwner: TControl);
  83.       destructor Destroy; override;
  84.       property ImageList: TImageList
  85.         read FImageList;
  86.  
  87.       property OnChange: TNotifyEvent
  88.         read FOnChange
  89.         write FOnChange;
  90.  
  91.       property OnChangeGlyph: TNotifyEvent
  92.         read FOnChangeGlyph
  93.         write FOnChangeGlyph;
  94.  
  95.     published
  96.       property Glyph: TBitmap
  97.         read FGlyph
  98.         write SetGlyph;
  99.  
  100.       property NumGlyphs: Word
  101.         read FNumGlyphs
  102.         write SetNumGlyphs
  103.         default 0;
  104.  
  105.       property Position: TExtGlyphPosition
  106.         read FPosition
  107.         write SetPosition
  108.         default glPosLeft;
  109.  
  110.       property Spacing: Integer
  111.         read FSpacing
  112.         write SetSpacing
  113.         default 5;
  114.  
  115.       property TransparentColor: TColor
  116.         read FTransparentColor
  117.         write SetTransparentColor
  118.         default clFuchsia;
  119.   end;
  120.  
  121.   EExtPageInvalidCall = class(Exception);
  122.  
  123.   TExtNbDrawTabEvent = procedure(Control: TWinControl; Index: Integer;
  124.                                  ActiveTab: Boolean; const RectFg, RectBg: TRect;
  125.                                  State: TOwnerDrawState) of object;
  126.  
  127.   TExtTabStyle = (tabStDefault, tabStButton);
  128.   TExtTabPosition = (tabPosLeft, tabPosRight, tabPosTop, tabPosBottom);
  129.  
  130.   TExtPageControl = class(TPageControl)
  131.     private
  132.       FCanvas: TCanvas;
  133.       FHintOrg: String;
  134.       FirstPaint: Boolean;
  135.       FLastTabHintIndex: Integer;
  136.       FOnDrawTab: TExtNbDrawTabEvent;
  137.       FTabActiveColor: TColor;
  138.       FTabActiveFont: TFont;
  139.       FTabGlyphs: TExtGlyphs;
  140.       FTabHeight: Word;
  141.       FTabHints: TStringList;
  142.       FTabInactiveColor: TColor;
  143.       FTabInactiveFont: TFont;
  144.       FTabPosition: TExtTabPosition;
  145.       FTabStyle: TExtTabStyle;
  146.       FTabWidth: Word;
  147.       FTabWordWrap: Boolean;
  148.       StopBGPainting: Boolean;
  149.       StopBGPaintingTabs: Boolean;
  150.       StopFGPaintingTabs: Boolean;
  151.       procedure CheckAndSetHWndFont;
  152.       function GetActivePage: TTabSheet;
  153.       procedure SetActivePage(Value: TTabSheet);
  154.       procedure SetTabActiveColor(Value: TColor);
  155.       procedure SetTabActiveFont(Value: TFont);
  156.       procedure SetTabGlyphs(Value: TExtGlyphs);
  157.       procedure SetTabHeight(Value: Word);
  158.       procedure SetTabHints(Value: TStringList);
  159.       procedure SetTabInactiveColor(Value: TColor);
  160.       procedure SetTabInactiveFont(Value: TFont);
  161.       procedure SetTabPosition(Value: TExtTabPosition);
  162.       procedure SetTabStyle(Value: TExtTabStyle);
  163.       procedure SetTabWidth(Value: Word);
  164.       procedure SetTabWordWrap(Value: Boolean);
  165.       procedure CMDialogChar(var Msg: TCMDialogChar); message CM_DIALOGCHAR;
  166.       procedure CMFontChanged(var Msg: TMessage); message CM_FONTCHANGED;
  167.       procedure CMHintShow(var Msg: TMessage); message CM_HINTSHOW;
  168.       procedure CMParentColorChanged(var Msg: TMessage); message CM_PARENTCOLORCHANGED;
  169.       procedure CNDrawTab(var Msg: TWMDrawItem); message CN_DRAWITEM;
  170.       procedure TCMInsertItem(var Msg: TMessage); message TCM_INSERTITEM;
  171.       procedure WMEraseBkgnd(var Msg: TWMEraseBkgnd); message WM_ERASEBKGND;
  172.       procedure WMLButtonDown(var Msg: TWMLButtonDown); message WM_LBUTTONDOWN;
  173.       procedure WMPaint(var Msg: TWMPaint); message WM_PAINT;
  174.       procedure WMSetCursor(var Msg: TWMSetCursor); message WM_SETCURSOR;
  175.     protected
  176.       procedure ChangeScale(M, D: Integer); override;
  177.       procedure CreateParams(var Params: TCreateParams); override;
  178.       procedure CreateWnd; override;
  179.       procedure FillTabBG(DC: HDC; ActiveTab: Boolean; const TabRect: TRect); virtual;
  180.       function GetTabNumber(CurrentPos: TPoint): Integer; virtual;
  181.       procedure GlyphHasChanged(Sender: TObject);
  182.       procedure GlyphHasChangedPicture(Sender: TObject);
  183.       procedure Loaded; override;
  184.       procedure ReAlignTabSheets; virtual;
  185.       procedure TabFontChanged(Sender: TObject); virtual;
  186.       function TabTextOut(Rect: TRect; Margin: TPoint; Text: String;
  187.                           Align: TAlignment; Disabled: Boolean): TPoint; virtual;
  188.     public
  189.       constructor Create(AOwner: TComponent); override;
  190.       destructor Destroy; override;
  191.       procedure BeginUpdate; virtual;
  192.       procedure DefaultDrawTab(Index: Integer; const RectFg: TRect;
  193.                                State: TOwnerDrawState); virtual;
  194.       procedure DestroyAllOtherSheetHandles; virtual;
  195.       procedure DrawTab(Index: Integer; ActiveTab: Boolean;
  196.                         const RectFg, RectBg: TRect; State: TOwnerDrawState); virtual;
  197.       procedure EndUpdate; virtual;
  198.       function GetPageIndexByTabIndex(CurrentTabIndex: Integer): Integer;
  199.       procedure GetSheetRect(var SheetRect: TRect); virtual;
  200.       function IsNewComCtl: Boolean;
  201.       property Canvas: TCanvas read FCanvas;
  202.     published
  203.       property ActivePage: TTabSheet
  204.         read GetActivePage
  205.         write SetActivePage;
  206.  
  207.       property Color;
  208.       property ParentColor;
  209.  
  210.       property TabActiveColor: TColor
  211.         read FTabActiveColor
  212.         write SetTabActiveColor;
  213.  
  214.       property TabActiveFont: TFont
  215.         read FTabActiveFont
  216.         write SetTabActiveFont;
  217.  
  218.       property TabGlyphs: TExtGlyphs
  219.         read FTabGlyphs
  220.         write SetTabGlyphs;
  221.  
  222.       property TabHeight: Word
  223.         read FTabHeight
  224.         write SetTabHeight;
  225.  
  226.       property TabHints: TStringList
  227.         read FTabHints
  228.         write SetTabHints;
  229.  
  230.       property TabInactiveColor: TColor
  231.         read FTabInactiveColor
  232.         write SetTabInactiveColor;
  233.  
  234.       property TabInactiveFont: TFont
  235.         read FTabInactiveFont
  236.         write SetTabInactiveFont;
  237.  
  238.       property TabPosition: TExtTabPosition
  239.         read FTabPosition
  240.         write SetTabPosition
  241.         default tabPosTop;
  242.  
  243.       property TabStyle: TExtTabStyle
  244.         read FTabStyle
  245.         write SetTabStyle
  246.         default tabStDefault;
  247.  
  248.       property TabWidth: Word
  249.         read FTabWidth
  250.         write SetTabWidth;
  251.  
  252.       property TabWordWrap: Boolean
  253.         read FTabWordWrap
  254.         write SetTabWordWrap
  255.         default False;
  256.  
  257.       property OnDrawTab: TExtNbDrawTabEvent
  258.         read FOnDrawTab
  259.         write FOnDrawTab;
  260.   end;
  261.  
  262.   TExtTabControl = class(TTabControl)
  263.     private
  264.       FCanvas: TCanvas;
  265.       FHintOrg: String;
  266.       FirstPaint: Boolean;
  267.       FLastTabHintIndex: Integer;
  268.       FOnDrawTab: TExtNbDrawTabEvent;
  269.       FTabActiveColor: TColor;
  270.       FTabActiveFont: TFont;
  271.       FTabDisabledList: TList;
  272.       FTabGlyphs: TExtGlyphs;
  273.       FTabHeight: Word;
  274.       FTabHints: TStringList;
  275.       FTabInactiveColor: TColor;
  276.       FTabInactiveFont: TFont;
  277.       FTabPosition: TExtTabPosition;
  278.       FTabStyle: TExtTabStyle;
  279.       FTabWidth: Word;
  280.       FTabWordWrap: Boolean;
  281.       StopBGPainting: Boolean;
  282.       StopBGPaintingTabs: Boolean;
  283.       StopFGPaintingTabs: Boolean;
  284.       procedure CheckAndSetHWndFont;
  285.       function GetTabEnabled(Index: Integer): Boolean;
  286.       function GetTabIndex: Integer;
  287.       procedure SetTabActiveColor(Value: TColor);
  288.       procedure SetTabActiveFont(Value: TFont);
  289.       procedure SetTabEnabled(Index: Integer; Value: Boolean);
  290.       procedure SetTabGlyphs(Value: TExtGlyphs);
  291.       procedure SetTabHeight(Value: Word);
  292.       procedure SetTabHints(Value: TStringList);
  293.       procedure SetTabInactiveColor(Value: TColor);
  294.       procedure SetTabInactiveFont(Value: TFont);
  295.       procedure SetTabIndex(Value: Integer);
  296.       procedure SetTabPosition(Value: TExtTabPosition);
  297.       procedure SetTabStyle(Value: TExtTabStyle);
  298.       procedure SetTabWidth(Value: Word);
  299.       procedure SetTabWordWrap(Value: Boolean);
  300.       procedure CMDialogChar(var Msg: TCMDialogChar); message CM_DIALOGCHAR;
  301.       procedure CMFontChanged(var Msg: TMessage); message CM_FONTCHANGED;
  302.       procedure CMHintShow(var Msg: TMessage); message CM_HINTSHOW;
  303.       procedure CMParentColorChanged(var Msg: TMessage); message CM_PARENTCOLORCHANGED;
  304.       procedure CNDrawTab(var Msg: TWMDrawItem); message CN_DRAWITEM;
  305.       procedure TCMInsertItem(var Msg: TMessage); message TCM_INSERTITEM;
  306.       procedure WMEraseBkgnd(var Msg: TWMEraseBkgnd); message WM_ERASEBKGND;
  307.       procedure WMLButtonDown(var Msg: TWMLButtonDown); message WM_LBUTTONDOWN;
  308.       procedure WMPaint(var Msg: TWMPaint); message WM_PAINT;
  309.       procedure WMSetCursor(var Msg: TWMSetCursor); message WM_SETCURSOR;
  310.     protected
  311.       procedure ChangeScale(M, D: Integer); override;
  312.       procedure CreateParams(var Params: TCreateParams); override;
  313.       procedure CreateWnd; override;
  314.       procedure FillTabBG(DC: HDC; ActiveTab: Boolean; const TabRect: TRect); virtual;
  315.       function GetTabNumber(CurrentPos: TPoint): Integer; virtual;
  316.       procedure GlyphHasChanged(Sender: TObject);
  317.       procedure GlyphHasChangedPicture(Sender: TObject);
  318.       procedure Loaded; override;
  319.       procedure TabFontChanged(Sender: TObject); virtual;
  320.       function TabTextOut(Rect: TRect; Margin: TPoint; Text: String;
  321.                           Align: TAlignment; Disabled: Boolean): TPoint; virtual;
  322.     public
  323.       constructor Create(AOwner: TComponent); override;
  324.       destructor Destroy; override;
  325.       procedure BeginUpdate; virtual;
  326.       procedure DefaultDrawTab(Index: Integer; const RectFg: TRect;
  327.                                State: TOwnerDrawState); virtual;
  328.       procedure DrawTab(Index: Integer; ActiveTab: Boolean;
  329.                         const RectFg, RectBg: TRect; State: TOwnerDrawState); virtual;
  330.       procedure EndUpdate; virtual;
  331.       procedure GetSheetRect(var SheetRect: TRect); virtual;
  332.       function IsNewComCtl: Boolean;
  333.       property Canvas: TCanvas
  334.         read FCanvas;
  335.  
  336.       property TabEnabled[Index: Integer]: Boolean
  337.         read GetTabEnabled
  338.         write SetTabEnabled;
  339.     published
  340.       property Color;
  341.       property ParentColor;
  342.  
  343.       property TabActiveColor: TColor
  344.         read FTabActiveColor
  345.         write SetTabActiveColor;
  346.  
  347.       property TabActiveFont: TFont
  348.         read FTabActiveFont
  349.         write SetTabActiveFont;
  350.  
  351.       property TabGlyphs: TExtGlyphs
  352.         read FTabGlyphs
  353.         write SetTabGlyphs;
  354.  
  355.       property TabHeight: Word
  356.         read FTabHeight
  357.         write SetTabHeight;
  358.  
  359.       property TabHints: TStringList
  360.         read FTabHints
  361.         write SetTabHints;
  362.  
  363.       property TabInactiveColor: TColor
  364.         read FTabInactiveColor
  365.         write SetTabInactiveColor;
  366.  
  367.       property TabInactiveFont: TFont
  368.         read FTabInactiveFont
  369.         write SetTabInactiveFont;
  370.  
  371.       property TabIndex: Integer
  372.         read GetTabIndex
  373.         write SetTabIndex;
  374.  
  375.       property TabPosition: TExtTabPosition
  376.         read FTabPosition
  377.         write SetTabPosition
  378.         default tabPosTop;
  379.  
  380.       property TabStyle: TExtTabStyle
  381.         read FTabStyle
  382.         write SetTabStyle
  383.         default tabStDefault;
  384.  
  385.       property TabWidth: Word
  386.         read FTabWidth
  387.         write SetTabWidth;
  388.  
  389.       property TabWordWrap: Boolean
  390.         read FTabWordWrap
  391.         write SetTabWordWrap
  392.         default False;
  393.  
  394.       property OnDrawTab: TExtNbDrawTabEvent
  395.         read FOnDrawTab
  396.         write FOnDrawTab;
  397.   end;
  398.  
  399. procedure Register;
  400.  
  401. implementation
  402.  
  403.  ...
  404.  
  405. procedure Register;
  406. begin
  407.   RegisterComponents('Win95', [TExtPageControl]);
  408.   RegisterComponents('Win95', [TExtTabControl]);  
  409. end;
  410.  
  411. end.
  412.